(require 'cl)

(defun rg-load-file (filename)
  "parse a rosegarden save file into a lisp list"
  ;; just using zcat, because jka-compr is unusable here
  (with-temp-buffer
    (shell-command (concat "zcat " filename) t)
    (xml-parse-region 1 (point-max))))

(defstruct rg "structure representing a rosegarden music file"
  tracks segs unhandled (end 0))
(defstruct rg-seg "structure representing a segment in a rosegarden file"
  (start 0) (duration 0) (name "") notes (track (cons -1 "")) chord unhandled
  repeat)
(defstruct rg-note
  "structure representing an event within a segment in a rosegarden file"
  abs-time (type 0) (dur 0) (pitch 0) unhandled
  (subord 0) (timeOff 0) (velocity 0) raw-value lsb msb (number 0)
  (octaveoffset 0) clef dots ntype (OttavaShift 0) (HeightOnStaff 0)
  (notationduration 0) (base-time 0))

(defun rg-note-value (note)
  "extract the value from a pitch or controller event represented by an rg-note"
  (if (and (rg-note-lsb note) (rg-note-msb note))
      (+ (ash (rg-note-msb note) 7) (rg-note-lsb note))
    (if (or (rg-note-lsb note) (rg-note-msb note))
	(error "discrepancy in rg-note struct value member")
      (rg-note-raw-value note))))

(defun rg-debug-scoregen ()
  "test function for convenience while developing the rosegarden extension"
  (rg-proxyize "/home/justin/dontcha/testcase.rg"))

(defun rg-proxyize (rg-file)
  "load rosegarden file provided and make proxies out of empty segments which
share a name with non-empty segments"
  (rg-insert-proxies (rg-sc-notelist (rg-load-file rg-file))))

(defun rg-insert-proxies (rg)
  (let ((seghash (make-hash-table)) res)
      (dolist (seg (rg-segs rg))
	(push (rg-normalize-seg seg)
	      (gethash (intern
			(if (string-match " \(copied\)" (rg-seg-name seg))
			    (substring (rg-seg-name seg) 0 (car (match-data)))
			  (rg-seg-name seg)))
		       seghash)))
      (maphash
       (lambda (key value)
	 (let (nonsilent)
	   (setq nonsilent
		 (or (remove-if (lambda (x)
				  (not (find-if
					(lambda (y)
					  (eq (rg-note-type y) 'note))
					(rg-seg-notes x))))
				value)
		     (remove-if (lambda (x)
				  (not (find-if
					(lambda (y) (not (eq (rg-note-type y)
							     'rest)))
					(rg-seg-notes x))))
				value)))
	   (puthash key (if (> (length nonsilent) 1)
			    nonsilent
			  (car nonsilent))
		    seghash)))
       seghash)
      (dolist (seg (rg-segs rg)) (setf (rg-seg-notes seg)
				       (gethash (intern (rg-seg-name seg))
						seghash))))
  rg)

(defun rg-unchord (rg)
  "extract repeats in rosegarden into sequences of notes"
  (let ((res (copy-rg rg)) notes)
    (dolist (x (rg-segs res))
      (dolist (y (rg-seg-notes x))
	(incf (rg-note-abs-time y) (rg-seg-start x))
	(push (copy-rg-note y) notes)
	(while (and (rg-seg-repeat x)
		    (< (rg-note-abs-time y) (rg-end res)))
	  (incf (rg-note-abs-time y) (rg-seg-duration x))
	  (push (copy-rg-note y) notes))))
    (sort notes (lambda (x y) (< (rg-note-abs-time x) (rg-note-abs-time y))))))

(defun rg-normalize-seg (seg)
  "extract chords from a rosegarden segment into sequences of notes"
  (let ((end 0) (start 0) result)
    (dolist (ele (rg-seg-notes seg))
      (when (and (rg-seg-p ele) (rg-seg-chord ele))
	(setq ele (rg-extract-chord ele end))
	(setq end (+ (rg-seg-start ele) (rg-seg-duration ele)))
	(setq result (append (rg-seg-notes ele) result)))
      (when (rg-note-p ele)
	(setq start (max 0 (+ (or (rg-note-abs-time ele) end)
			      (rg-note-timeOff ele))))
	(setq end (+ start (rg-note-dur ele)))
	(setf (rg-note-abs-time ele) start)
	(push ele result)))
    (setf (rg-seg-duration seg) end)
    (setf (rg-seg-notes seg)
	  (sort result (lambda (x y)
			 (< (rg-note-abs-time x) (rg-note-abs-time y)))))
    seg))

(defun rg-extract-chord (seg start)
  "normalize note times within an rg segment representing a chord"
  (let ((max 0))
    (dolist (ele (rg-seg-notes seg))
      (setq start (max 0 (+ (rg-note-timeOff ele) start)))
      (setq max (max (rg-note-dur ele) max)))
    (setf (rg-seg-start seg) start)
    (setf (rg-seg-duration seg) max)
    (dolist (ele (rg-seg-notes seg))
      (setf (rg-note-abs-time ele) (or (rg-note-abs-time ele) start)))
  seg))

(defun rg-sc-notelist (rg-data)
  "take the list representation of a rosegarden save file and extract the data
to a form usable for translation to supercollider, csound, etc. event lists"
  (let ((rg (make-rg)))
    (dolist (ele (car rg-data))
      (cond ((consp ele)
	     (rg-score-tag ele rg))
	    ((and (stringp ele) (string-match "[ \n]*" ele))
	     '())
	    ((eq ele 'rosegarden-data)
	     '())
	    (t (push  (list 'rg-sc-notelist ele) (rg-unhandled rg)))))
    (setf (rg-segs rg) (nreverse (rg-segs rg)))
    rg))

(defun rg-score-tag (ele rg)
  "get the data we find interesting from a rosegarden file, and put it into
an rg struct"
  (cond ((consp (car ele))
	 (cond
	  ((eq (caar ele) 'version) '())
	  (t (push (list 'cons-score-tag ele) (rg-unhandled rg)))))
	((eq (car ele) 'segment)
	 (push (rg-extract-seg (cdr ele) nil nil) (rg-segs rg)))
	((eq (car ele) 'composition)
	 (rg-get-composition (cdr ele) rg))
	((eq (car ele) 'appearance) '())
	((eq (car ele) 'configuration) '())
	((eq (car ele) 'audiofiles) '())
	((eq (car ele) 'studio) '())
	(t (push (list 'atom-score-tag ele) (rg-unhandled rg))))
  rg)

(defun rg-get-composition (arg rg)
  "get the interesting data from the composition tag of a rosegarden save file into an rg struct"
  (dolist (item arg)
    (if (consp item)
	(cond ((eq (car item) 'track)
	       (push (cdr item) (rg-tracks rg)))
	      ((eq (car item) 'markers)
	        (find-if (lambda (x)
			   (and (consp x)
				(eq (car x) 'marker)
				(equal "end" (cdr (assoc 'name (cadr x))))
				(setf (rg-end rg)
				      (string-to-number
				       (cdr (assoc 'time (cadr x)))))))
			 item))
	      (t (push (list 'composition-cons item) (rg-unhandled rg))))
      (unless (and (stringp item) (string-match "[ \n]*" item))
	(push (list 'composition-atom item) (rg-unhandled rg)))))
  rg)

(defun rg-extract-seg (rawseg chord name)
  "get the data from a segment within a rosegarden save file"
  (let ((new-seg (make-rg-seg)) res)
    (when chord
      (setf (rg-seg-chord new-seg) t)
      (setf (rg-seg-name new-seg) name))
    (dolist (ele rawseg)
      (when (not (consp ele))
	(unless (or (not ele) (and (stringp ele) (string-match "[ \n]*" ele)))
	  (push (list 'standalone ele) (rg-seg-unhandled new-seg))))
      (when (consp ele)
	(when (consp (car ele))
	  (if (eq (caar ele) 'track)
	      (progn (when (setq res (assq 'track ele))
		       (setf (rg-seg-track new-seg)
			     (string-to-number (cdr res))))
		     (when (setq res (assq 'label ele))
		       (setf (rg-seg-name new-seg) (cdr res)))
		     (when (setq res (assq 'repeat ele))
		       (setf (rg-seg-repeat new-seg) t))
		     (when (setq res (assq 'start ele))
		       (setf (rg-seg-start new-seg)
			     (string-to-number (cdr res)))))
	    (push (list 'cons-seg ele) (rg-seg-unhandled new-seg))))
	(when (not (consp (car ele)))
	  (cond ((eq (car ele) 'event)
		 (push (rg-extract-event (cdr ele)) (rg-seg-notes new-seg)))
		((eq (car ele) 'chord)
		 (push (rg-extract-seg (cdr ele) t name)
		       (rg-seg-notes new-seg)))
		((eq (car ele) 'gui) '())
		((eq (car ele) 'end) '())
		((eq (car ele) 'begin) '())
		(t (push (list 'seg ele) (rg-seg-unhandled new-seg)))))))
    (setf (rg-seg-notes new-seg) (nreverse (rg-seg-notes new-seg)))
    new-seg))

(defun rg-extract-event (event-raw)
  "get an event from a segment in a rosegarden save file and put it into an rg-note struct"
  (let ((new-note (make-rg-note)) name)
    (dolist (e event-raw)
      (unless (consp (car e))
	(setq e (cadr e)))
      (cond ((eq (caar e) 'type)
	     (setf (rg-note-type new-note) (intern (cdar e)))
	     (when (assq 'duration e)
	       (setf (rg-note-dur new-note) (string-to-number
				       (cdr (assq 'duration e)))))
	     (when (assq 'subordering e)
	       (setf (rg-note-subord new-note) (string-to-number
					  (cdr (assq 'subordering e)))))
	     (when (assq 'timeOffset e)
	       (setf (rg-note-timeOff new-note) (string-to-number
					   (cdr (assq 'timeOffset e)))))
	     (when (assq 'absoluteTime e)
	       (setf (rg-note-abs-time new-note) (string-to-number
					(cdr (assq 'absoluteTime e))))))
	    ((equal (cdar e) "pitch")
	     (setf (rg-note-pitch new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "velocity")
	     (setf (rg-note-velocity new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "value")
	     (setf (rg-note-raw-value new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "lsb")
	     (setf (rg-note-lsb new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "msb")
	     (setf (rg-note-msb new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "number")
	     (setf (rg-note-number new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "octaveoffset")
	     (setf (rg-note-octaveoffset new-note)
		   (string-to-number (cdadr e))))
	    ((equal (cdar e) "clef")
	     (setf (rg-note-clef new-note) (intern (cdadr e))))
	    ((equal (cdar e) "notetype")
	     (setf (rg-note-ntype new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "notedots")
	     (setf (rg-note-dots new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "OttavaShift")
	     (setf (rg-note-OttavaShift new-note) (string-to-number (cdadr e))))
	    ((equal (cdar e) "HeightOnStaff")
	     (setf (rg-note-HeightOnStaff new-note)
		   (string-to-number (cdadr e))))
	    ((equal (cdar e) "!notationduration")
	     (setf (rg-note-notationduration new-note)
		   (string-to-number (cdadr e))))
	    (t (push (list e) (rg-note-unhandled new-note)))))
    new-note))
